home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tpu6.zip / TPU6RPT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-16  |  5KB  |  234 lines

  1. {$D+,S+,L+,R-,I+}
  2.  
  3. UNIT TPU6RPT;
  4.  
  5. (*****************)
  6. (**) INTERFACE (**)
  7. (*****************)
  8.  
  9. USES Dos;
  10. CONST
  11.     Ctl_CRLF = ^M^J;    { "new-line" sequence for MS/PC Dos }
  12.     Ctl_FF   = ^L;        { "new-page" sequence for MS/PC Dos }
  13.  
  14. TYPE  FileFlags = (FileActive,FileQuiet,FileFailure);
  15.  
  16. VAR    LinesRemaining,        { on current page }
  17.     ColumnsRemaining,    { on current line }
  18.     ColumnsUsed        { on current line }
  19.             : LongInt;
  20.     FileStatus     : FileFlags;
  21.  
  22. PROCEDURE PutTxt(S : String);
  23. PROCEDURE PutCtl(S : String);
  24. PROCEDURE SetCol(I : Integer);
  25. PROCEDURE NewTxtLine;
  26. PROCEDURE NewTxtPage;
  27. PROCEDURE OpenTxt(S : String; LineMax, ColumnMax : Integer);
  28. PROCEDURE CloseTxt;
  29.  
  30. (**********************)
  31. (**) IMPLEMENTATION (**)
  32. (**********************)
  33.  
  34. CONST
  35.     Ctl_EOF  = ^Z;    { "end-file" sequence for MS/PC Dos }
  36.     Ctl_CR   = ^M;    { "Carriage-Return"                 }
  37.     Ctl_LF   = ^J;    { "Line-Feed"                       }
  38.  
  39. VAR    MaxLinesOnPage,
  40.     MaxColsPerLine,
  41.     CurrentLine,
  42.     CurrentColumn : LongInt;
  43.  
  44.     NoLineWrap, NoPageBreak : Boolean;
  45.  
  46.     FileState : FileFlags;
  47.     TextFile  : Text;
  48.         Spaces    : String;
  49.  
  50. PROCEDURE FeedBack;
  51. BEGIN
  52.     IF NOT (FileState = FileActive) THEN
  53.     BEGIN
  54.         LinesRemaining   := 0;
  55.         ColumnsRemaining := 0;
  56.         ColumnsUsed      := 0;
  57.     END ELSE
  58.     BEGIN
  59.         LinesRemaining   := MaxLinesOnPage + 1 - CurrentLine;
  60.         ColumnsRemaining := MaxColsPerLine + 1 - CurrentColumn;
  61.         ColumnsUsed      := CurrentColumn  - 1;
  62.     END;
  63.     FileStatus := FileState;
  64. END;    {FeedBack}
  65.  
  66. PROCEDURE PutCR;
  67. BEGIN
  68.     PutCtl(Ctl_CR);
  69.     CurrentColumn := 1;
  70. END;
  71.  
  72. PROCEDURE PutLF;
  73. BEGIN
  74.     IF NoPageBreak
  75.     THEN PutCtl(Ctl_LF)
  76.     ELSE
  77.         IF CurrentLine = MaxLinesOnPage THEN
  78.         BEGIN
  79.             PutCtl(Ctl_FF);
  80.             CurrentLine := 0
  81.         END
  82.         ELSE    PutCtl(Ctl_LF);
  83.  
  84.     Inc(CurrentLine);
  85. END;
  86.  
  87. PROCEDURE PutCRLF;
  88. BEGIN    PutCR;    PutLF;    END;
  89.  
  90. PROCEDURE PutFF;
  91. BEGIN    PutCtl(Ctl_FF);    CurrentLine := 1;    END;
  92.  
  93. PROCEDURE PutEOF;
  94. BEGIN    PutCtl(Ctl_EOF);    END;
  95.  
  96. FUNCTION ScanCtls(S : String):Integer;
  97. LABEL Found;
  98. VAR J : Integer; I, L : Byte;
  99. BEGIN
  100.     J := 0; L := Length(S);
  101.     FOR I := 1 TO L DO
  102.         IF S[I] in [Ctl_EOF,Ctl_FF,Ctl_LF,Ctl_CR]
  103.         THEN BEGIN
  104.             J := I; GOTO Found
  105.         END;
  106. Found:
  107.     ScanCtls := J
  108. END;
  109.  
  110. PROCEDURE PutTxt(S : String);
  111. VAR CtlPos, Slice : Integer;
  112. BEGIN
  113.     CtlPos := ScanCtls(S);
  114.     WHILE Length(S) > 0 DO BEGIN
  115.         IF CurrentColumn > MaxColsPerLine THEN PutCRLF;
  116.         IF CurrentLine   > MaxLinesOnPage THEN PutFF;
  117.         Slice := Length(S);
  118.         IF CtlPos = 0
  119.         THEN CtlPos := Slice + 1
  120.         ELSE
  121.             IF Slice > CtlPos
  122.             THEN Slice := CtlPos - 1;
  123.         IF Slice > MaxColsPerLine THEN Slice := MaxColsPerLine;
  124.         IF Slice > 0 THEN
  125.         BEGIN
  126.             PutCtl(Copy(S,1,Slice));
  127.             Delete(S,1,Slice);
  128.             CtlPos := CtlPos - Slice;
  129.             CurrentColumn := CurrentColumn + Slice
  130.         END ELSE
  131.         BEGIN
  132.             IF S[1] = Ctl_EOF THEN PutEOF ELSE
  133.             IF S[1] = Ctl_FF  THEN PutFF  ELSE
  134.             IF S[1] = Ctl_LF  THEN PutLF  ELSE
  135.             IF S[1] = Ctl_CR  THEN PutCR;
  136.             Delete(S,1,1);
  137.             IF Length(S) > 0 THEN CtlPos := ScanCtls(S);
  138.         END;
  139.     END; {WHILE}
  140.     FeedBack;
  141. END;
  142.  
  143. PROCEDURE PutCtl(S : String);
  144. BEGIN
  145.     IF FileState = FileActive THEN
  146.     BEGIN
  147.         {$I-} Write(TextFile,S); {$I+}
  148.         IF IOResult <> 0 THEN CloseTxt
  149.     END;
  150. END;
  151.  
  152. PROCEDURE NewTxtLine;
  153. BEGIN
  154.     PutCRLF;
  155.     FeedBack;
  156. END;
  157.  
  158. PROCEDURE NewTxtPage;
  159. BEGIN
  160.     IF CurrentColumn > 1 THEN PutCRLF;
  161.     IF CurrentLine > 1 THEN PutFF;
  162.     FeedBack;
  163. END;
  164.  
  165. PROCEDURE OpenTxt(S : String; LineMax, ColumnMax : Integer);
  166. BEGIN
  167.     IF FileState = FileActive THEN CloseTxt;
  168.  
  169.     Assign(TextFile,S);
  170.     NoPageBreak := (LineMax < 1) OR (LineMax > 255);
  171.     IF NoPageBreak
  172.         THEN MaxLinesOnPage := MaxLongInt
  173.         ELSE MaxLinesOnPage := LineMax;
  174.     NoLineWrap  := (ColumnMax < 1) OR (ColumnMax > 255);
  175.     IF NoLineWrap
  176.         THEN MaxColsPerLine := MaxLongInt
  177.         ELSE MaxColsPerLine := ColumnMax;
  178.     CurrentLine    := 1;
  179.     CurrentColumn  := 1;
  180.     FileState      := FileActive;
  181.  
  182.     {$I-} ReWrite(TextFile); {$I+}
  183.  
  184.     IF IOResult <> 0 THEN FileState := FileFailure;
  185.     IF FileState = FileFailure
  186.     THEN CloseTxt
  187.     ELSE FeedBack;
  188. END;
  189.  
  190. PROCEDURE SetCol(I : Integer);
  191. Var J : Integer;
  192. BEGIN
  193.     IF FileState = FileActive THEN
  194.     IF MaxColsPerLine > I   THEN
  195.     BEGIN
  196.         IF CurrentColumn  > I THEN PutCRLF;
  197.                 J := I - CurrentColumn;
  198.                 IF J < SizeOf(Spaces) THEN
  199.                 BEGIN
  200.                    Spaces[0] := Chr(J);
  201.                    PutTxt(Spaces);
  202.                 END ELSE
  203.         WHILE CurrentColumn < I DO PutTxt(' ')
  204.     END;
  205.     FeedBack;
  206. END;
  207.  
  208. PROCEDURE CloseTxt;
  209. BEGIN
  210.     IF FileState = FileActive THEN
  211.     BEGIN
  212.     {    PutEOF; }
  213.         {$I-} Close(TextFile); {$I+}
  214.         MaxLinesOnPage := 0;
  215.         MaxColsPerLine := 0;
  216.         CurrentLine    := 0;
  217.         CurrentColumn  := 0;
  218.         FileState      := FileQuiet;
  219.         NoLineWrap     := True;
  220.         NoPageBreak    := True;
  221.         FeedBack;
  222.     END;
  223. END;
  224.  
  225. BEGIN    { UNIT INITIALIZATION CODE }
  226.  
  227.         FillChar(Spaces,SizeOf(Spaces),' ');
  228.     MaxLinesOnPage := 0;
  229.     MaxColsPerLine := 0;
  230.     CurrentLine    := 0;
  231.     CurrentColumn  := 0;
  232.     FileState      := FileQuiet;
  233.     FeedBack;
  234. END.